11 Function operators

Introduction

function operators 本质也是一个function factories，只是规定输入是一个函数。下面的简单示例——chatty()函数，接受一个函数f，返回一个能打印f的输入的函数。

chatty <- function(f) {
  force(f)

  function(x, ...) {
    message("Processing ", x)
    f(x, ...)
  }
}
f <- function(x) x^2
s <- c(3, 2, 1)

purrr::map_dbl(s, chatty(f))
#> Processing 3
#> Processing 2
#> Processing 1
#> [1] 9 4 1

function operators 与 python 中的装饰器相同，遵循开放封闭原则，即对扩展开放，对修改封闭。它允许我们在不修改原有函数代码的情况下增加额外的功能，例如：为函数添加日志、权限检查、参数检查等多种功能，这使得代码更加模块化，易于维护和扩展。

Outline

• 11.2节介绍一些极其有用的 function operators 函数。

• 11.2节介绍如何根据实际问题，创建自己的 function operators 函数。

Prerequisites

function operators 本质是function factories，请先了解 function factory 函数。

本章会用到purrr包中的泛函和其提供的function operators函数，及 memoise 包中的memoise()函数。

library(purrr)
library(memoise)

Existing function operators

Capturing errors with purrr::safely()

在使用map()等函数替代for-loop时，我们通常会困扰于：如果函数执行过程中发生错误，那么map()函数会直接停止，不会返回已运行成功的部分结果，而for-loop则会保留部分结果。

x <- list(
  c(0.512, 0.165, 0.717),
  c(0.064, 0.781, 0.427),
  "oops",
  c(0.890, 0.785, 0.495)
)

out <- rep(NA_real_, length(x))
for (i in seq_along(x)) {
  out[[i]] <- sum(x[[i]])
}
#> Error in sum(x[[i]]): invalid 'type' (character) of argument

out
#> [1] 1.394 1.272    NA    NA

map_dbl(x, sum)
#> Error in `map_dbl()`:
#> ℹ In index: 3.
#> Caused by error:
#> ! invalid 'type' (character) of argument

上面的例子中，虽然最后会失败，但out会保留前面成功的结果，但map_dbl()则不会。如果我们使用safely()修改sum()，就会始终返回一个同时包含正确结果和错误信息的list。仔细观察结果，会进一步发现：for-loop在第三个循环失败后不再允许，map则会继续执行，它返回了第四个结果。

out <- map(x, safely(sum))
str(out)
#> List of 4
#>  $ :List of 2
#>   ..$ result: num 1.39
#>   ..$ error : NULL
#>  $ :List of 2
#>   ..$ result: num 1.27
#>   ..$ error : NULL
#>  $ :List of 2
#>   ..$ result: NULL
#>   ..$ error :List of 2
#>   .. ..$ message: chr "invalid 'type' (character) of argument"
#>   .. ..$ call   : language .Primitive("sum")(..., na.rm = na.rm)
#>   .. ..- attr(*, "class")= chr [1:3] "simpleError" "error" "condition"
#>  $ :List of 2
#>   ..$ result: num 2.17
#>   ..$ error : NULL

那么，safely()函数做了什么？打印safe_sum()，我们会发现它调用了capture_error()函数，捕获错误信息并返回。

safe_sum <- safely(sum)
safe_sum
#> function (...) 
#> capture_error(.f(...), otherwise, quiet)
#> <bytecode: 0x000002c8bb963f60>
#> <environment: 0x000002c8bc128710>

str(safe_sum(x[[1]]))
#> List of 2
#>  $ result: num 1.39
#>  $ error : NULL
str(safe_sum(x[[3]]))
#> List of 2
#>  $ result: NULL
#>  $ error :List of 2
#>   ..$ message: chr "invalid 'type' (character) of argument"
#>   ..$ call   : language .Primitive("sum")(..., na.rm = na.rm)
#>   ..- attr(*, "class")= chr [1:3] "simpleError" "error" "condition"

由于safely()后的函数始终返回一个list——包含两个元素：result，error，我们可以使用purrr::transpose()函数，将map()的输出结果转置，得到一个包含两个元素的list，第一个元素是正常结果，第二个元素是错误信息。

out <- transpose(map(x, safely(sum)))
str(out)
#> List of 2
#>  $ result:List of 4
#>   ..$ : num 1.39
#>   ..$ : num 1.27
#>   ..$ : NULL
#>   ..$ : num 2.17
#>  $ error :List of 4
#>   ..$ : NULL
#>   ..$ : NULL
#>   ..$ :List of 2
#>   .. ..$ message: chr "invalid 'type' (character) of argument"
#>   .. ..$ call   : language .Primitive("sum")(..., na.rm = na.rm)
#>   .. ..- attr(*, "class")= chr [1:3] "simpleError" "error" "condition"
#>   ..$ : NULL

现在我们可以轻易地找到结果和错误原因。

ok <- map_lgl(out$error, is.null)
ok
#> [1]  TRUE  TRUE FALSE  TRUE

x[!ok]
#> [[1]]
#> [1] "oops"

out$result[ok]
#> [[1]]
#> [1] 1.394
#> 
#> [[2]]
#> [1] 1.272
#> 
#> [[3]]
#> [1] 2.17

safely()函数的使用场景有很多，我们可以总结出下面的使用规律：

f <- fcuntion (x, ...) {
  # do something
}

out <- transpose(map(x, safely(f)))
ok <- map_lgl(out$error, is.null)

# which data failed to converge?
x[!ok]

# which models were successful?
out$result[ok]

Other function operators in purrr

• possibly()：当函数报错时，返回默认值，无法判断是否发生了错误。

• quietly()：返回函数中除报错的其他信息。

f <- function() {
  print("Hi!")
  message("Hello")
  warning("How are ya?")
  "Gidday"
}
f()
#> [1] "Hi!"
#> Hello
#> Warning in f(): How are ya?
#> [1] "Gidday"

f_quiet <- quietly(f)
str(f_quiet())
#> List of 4
#>  $ result  : chr "Gidday"
#>  $ output  : chr "[1] \"Hi!\""
#>  $ warnings: chr "How are ya?"
#>  $ messages: chr "Hello\n"

• as_browse()：当函数报错时，进入断点调试模式。

Caching computations with memoise::memoise()

memoises 使函数可以缓存之前的输入和输出。这种缓存能力势必会增加内存的消耗，但却会提高计算的速度。

slow_function <- function(x) {
  Sys.sleep(1)
  x * 10 * runif(1)
}
system.time(print(slow_function(1)))
#> [1] 4.170535
#>    user  system elapsed 
#>    0.00    0.00    1.02

system.time(print(slow_function(1)))
#> [1] 5.910717
#>    user  system elapsed 
#>    0.00    0.00    1.01

上面的例子中，每次运行结果都会不同，但是当被memoises后，第一次的结果就会被缓存，当输入相同时，就会直接返回缓存的结果。

fast_function <- memoise::memoise(slow_function)
system.time(print(fast_function(1)))
#> [1] 7.387216
#>    user  system elapsed 
#>    0.00    0.00    1.09

system.time(print(fast_function(1)))
#> [1] 7.387216
#>    user  system elapsed 
#>    0.02    0.00    0.01

另外一个例子是计算斐波那契数列（f(0) = 0, f(1) = 1, f(n) = f(n-1) + f(n-2)）。

fib <- function(n) {
  if (n < 2) {
    return(n)
  }
  fib(n - 2) + fib(n - 1)
}
system.time(fib(23))
#>    user  system elapsed 
#>    0.03    0.00    0.03
system.time(fib(24))
#>    user  system elapsed 
#>    0.04    0.00    0.05

将fib()memoises化后， 当计算完fib2(23)后，fib2(24)的计算速度会非常快。

fib2 <- memoise::memoise(function(n) {
  if (n < 2) {
    return(n)
  }
  fib2(n - 2) + fib2(n - 1)
})
system.time(fib2(23))
#>    user  system elapsed 
#>       0       0       0
system.time(fib2(24))
#>    user  system elapsed 
#>       0       0       0

在动态规划中（dynamic programming），memoises更加常见。

但在memoises化函数之前，要检查函数是否是pure的。

Case study: Creating your own function operators

下面我们以一个下载数据的例子，介绍如何编写自己的function operator。

假设你有很多书籍的网址，你想要下载这些书籍。使用前面章节中的walk2()和file.download()，可以简单地写为：

urls <- c(
  "adv-r" = "https://adv-r.hadley.nz",
  "r4ds" = "http://r4ds.had.co.nz/"
  # and many many more
)
path <- paste0(tempdir(), names(urls), ".html")

walk2(urls, path, download.file, quiet = TRUE)

上面的方法在urls不是很长时，确实足够。但当urls变得很长时，你就需要考虑：

• 每本书下载后要添加一个延时，避免阻塞服务器。

• 显示下载的进度。

使用for-loop可以轻松解决上面两点，但for-loop将“下载”、“延时”，“显示进度”三个不同目的的东西都放在了一起，会让代码难于阅读。

for (i in seq_along(urls)) {
  Sys.sleep(0.1)
  if (i %% 10 == 0) cat(".")
  download.file(urls[[i]], path[[i]], quiet = TRUE)
}

我们使用function operators来将这三个目的分开。首先创建“延时”函数delay_by()：接受两个参数——函数，延时时长

delay_by <- function(f, amount) {
  force(f)
  force(amount)

  function(...) {
    Sys.sleep(amount)
    f(...)
  }
}
system.time(runif(100))
#>    user  system elapsed 
#>       0       0       0
system.time(delay_by(runif, 0.1)(100))
#>    user  system elapsed 
#>    0.00    0.00    0.11

将delay_by()应用到download.file()中：

walk2(urls, path, delay_by(download.file, 0.1), quiet = TRUE)

接下来创建“显示进度”函数dot_every()：接受两个参数——函数，显示点的间隔

dot_every <- function(f, n) {
  force(f)
  force(n)

  i <- 0
  function(...) {
    i <<- i + 1
    if (i %% n == 0) cat(".")
    f(...)
  }
}
walk(1:100, runif)
walk(1:100, dot_every(runif, 10))
#> ..........

将dot_every()应用到download.file()中：

walk2(
  urls, path,
  dot_every(delay_by(download.file, 0.1), 10),
  quiet = TRUE
)

我们也可以使用管道符%>%将函数串起来写：

walk2(
  urls, path,
  download.file %>% delay_by(0.1) %>% dot_every(10),
  quiet = TRUE
)